;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright 2021 fanguangping
; 
; Licensed under the Apache License, Version 2.0 (the "License");
; you may not use this file except in compliance with the License.
; You may obtain a copy of the License at
; 
;     http://www.apache.org/licenses/LICENSE-2.0
; 
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
; See the License for the specific language governing permissions and
; limitations under the License.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#lang racket

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Object class: the root class
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require "../common/constants.scm")
(require "../common/messages.scm")
(require "../common/utils.scm")

(provide create-instance
         ask
         CREATE-Object
         MAKE-Object
         get-method
         object-equals?
         object-hash-code
         object-to-string
         object-type
         display-object
         displayln-object)

(define +SET-HANDLER!+    0)

(define (make-instance)
  (let ((handler +nil+))
    (lambda (message)
      (cond
        ((= message +SET-HANDLER!+)
         (lambda (handler-proc)
           (set! handler handler-proc)))
        (else (get-method message handler))))))

(define (create-instance maker . args)
  (let* ((instance (make-instance))
         (handler (apply maker instance args)))
    (ask instance +SET-HANDLER!+ handler)
    instance))

(define (create-root-object) (create-instance make-root-object))

(define (make-root-object self) (lambda (message) (self message)))

(define (get-method message object) (object message))

(define (ask object message . args)
  (let ((method (get-method message object)))
    (if (not-null? method)
        (apply method args)
        (error "No method for message" message))))

(define (CREATE-Object) (create-instance MAKE-Object))

(define (MAKE-Object self)
  (let ((root-part (make-root-object self)))
    (lambda (message)
      (cond
        ((= message +M-Object-equals+) (lambda (other) (equal? (object-type other) 'Object)))
        ((= message +M-Object-hash-code+) (lambda () -1))
        ((= message +M-Object-to-string+) (lambda () +nil+))
        ((= message +M-Object-type+) (lambda () 'Object))
        (else (get-method message root-part))))))

(define (object-equals? obj other)
  (if (procedure? obj) (ask obj +M-Object-equals+ other)
      (equal? obj other)))

(define (object-hash-code obj)
  (if (procedure? obj) (ask obj +M-Object-hash-code+)
      (equal-hash-code obj)))

(define (object-to-string obj)
  (if (procedure? obj) (ask obj +M-Object-to-string+)
      (format "~a" obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; with built-in object type
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (object-type obj)
  (if (procedure? obj) (ask obj +M-Object-type+)
      (cond
        ((string? obj) 'string)
        ((symbol? obj) 'symbol)
        ((real? obj) 'number)
        ((char? obj) 'character)
        ((boolean? obj) 'boolean)
        ((vector? obj) 'vector)
        ((pair? obj) 'pair)
        (else +nil+))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Description: display object with newline
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (displayln-object object)
  (displayln (object-to-string object)))

(define (display-object object)
  (display (object-to-string object)))
